Personal Computer World 2006 May/PCWMAY06.iso/Software/Trial/ConceptDraw NetDiagrammer/data1.cab/Libraries__Project_Management/Project_Management/Outline.cdb

Text File | 2006-02-08 | 9KB | 315 lines

Dim intPrevTaskID As Long

Function CreateTaskObjects(recLevel As Integer, recName As String, recDuration As Double, recStart As Date, recEnd As Date, recComplete As Double, recIsPhase As Integer) As Integer
On Error Goto ErrorHandle
    Dim ProjectLib        As Library
    Dim libTaskBar        As Master
    Dim libTimeLine        As Master
    Dim shapeTask        As Shape
    Dim shapeTasksTitle    As Shape

    Dim dblPosS            As Double
    Dim dblPosE            As Double
    Dim dblPosC            As Double
    Dim dblDayWidth        As Double
    Dim dblCalStart        As Double

    Set ProjectLib    = thisApp.OpenLib("Project Management/Gantt Chart Shapes.cdl")
    If ProjectLib = Null Then
        Exit Function
    End If
    Set libTaskBar = ProjectLib.MasterByName("TaskBar")
    If libTaskBar = Null Then
        Exit Function
    End If

    Set shapeTasksTitle = GetTasksTitle()
    If shapeTasksTitle = Null Then
        Exit Function
    End If
    dblDayWidth = shapeTasksTitle.CustomProp(1).Value
    dblCalStart = shapeTasksTitle.CustomProp(2).Value

    Dim Y As Double
    Dim shp As Shape
    If intPrevTaskID = 0 Then
        Y = shapeTasksTitle.GPinY + shapeTasksTitle.Height
    Else
        Set shp = thisDoc.ActivePage.ShapeByID(intPrevTaskID)
        Y = shp.GPinY + shp.Height
    End If

    shapeTasksTitle.Variable(3).X = 1
    Set shapeTask = thisDoc.ActivePage.DropStamp(libTaskBar.Shape, shapeTasksTitle.GPinX, Y)
    shapeTasksTitle.Variable(3).X = 0

    libTimeLine = Null
    If recIsPhase = 1 Then
        shapeTask.Variable(10).X = 1
        shapeTask.PropertyChanged(CDPT_VARIABLE_X, 10)
        Set libTimeLine = ProjectLib.MasterByName("TimeLineS3")
    ElseIf recDuration = 0 Then
        Set libTimeLine = ProjectLib.MasterByName("MilestoneN1")
    End If
    If libTimeLine <> Null Then
        thisDoc.ActivePage.DropStamp(libTimeLine.Shape, shapeTask.GPinX + shapeTask.Width*0.5, shapeTask.GPinY + shapeTask.Height*0.5)
    End If

    dblPosS = (recStart - dblCalStart) * dblDayWidth + shapeTask.Variable(6).X
    shapeTask.ControlDot(1).X = dblPosS
    dblPosE = (recEnd - dblCalStart + 1) * dblDayWidth + shapeTask.Variable(6).X
    shapeTask.ControlDot(2).X = dblPosE
    dblPosC = (dblPosE - dblPosS) * recComplete / 100 + dblPosS
    shapeTask.ControlDot(3).X = dblPosC

    shapeTask.CustomProp(1).Value = recName
    shapeTask.Variable(9).X = recLevel

    shapeTask.PropertyChanged(CDPT_CONTROL_X, 1)
    shapeTask.PropertyChanged(CDPT_CONTROL_X, 2)
    shapeTask.PropertyChanged(CDPT_CONTROL_X, 3)
    shapeTask.PropertyChanged(CDPT_CUSTOM_VALUE, 1)
    shapeTask.PropertyChanged(CDPT_VARIABLE_X, 9)

    intPrevTaskID = shapeTask.ID
ErrorHandle:
End Function

Sub PlaceLegend(inTaskBottomID As Integer)
'    Set shapeLegend = thisDoc.ActivePage.DropStamp(libLegend.Shape, 0, 0)
'    strFormula = "=ObjID" & shapeTasksTitle.ID & ".GPinX"
'    shapeLegend.SetPropertyFormula(strFormula, CDPT_GPINX)
'    strFormula = "=ObjID" & inTaskBottomID & ".GPinY + ObjID" & inTaskBottomID & ".Height"
'    shapeLegend.SetPropertyFormula(strFormula, CDPT_GPINY)
'
'    shapeLegend.RecalcProperty(CDPT_GPINX)
'    shapeLegend.RecalcProperty(CDPT_GPINY)
End Sub

Function GetRecomendetTimeScale(startc As Double, endc As Double) As Integer
    Dim period As Double
    period = endc - startc
    If period > 365*20 Then
        GetRecomendetTimeScale = 5
    ElseIf period > 365*5 Then
        GetRecomendetTimeScale = 4
    ElseIf period > 365 Then
        GetRecomendetTimeScale = 3
    ElseIf period > 365*0.5 Then
        GetRecomendetTimeScale = 2
    Else
        GetRecomendetTimeScale = 1
    End If
End Function

Function LoadOutline(shapeTasksTitle As Shape, strFileName As String) As Boolean
On Error Goto ErrorHandle
    Dim intFileNumber        As Integer
    Dim strLineData            As String
    Dim intSeparatorPos        As Integer
    Dim intFieldNum            As Integer
    Dim intLastTaskTableID    As integer

    Dim recLevel            As Integer
    Dim recIsPhase            As Integer
    Dim recName                As String
    Dim recDuration            As Double
    Dim recStart            As Double
    Dim recEnd                As Double
    Dim recComplete            As Double
    Dim strFormula            As String
    Dim tmpCalStart            As Double
    Dim tmpCalEnd            As Double

    Dim intLineNum            As Long
    Dim arrayLines()        As String

    intFileNumber = FreeFile()
    Open strFileName For Input As #intFileNumber
    tmpCalStart    = 0
    tmpCalEnd    = 0
    intLineNum    = 0
    Do While Not EOF(intFileNumber)
        Line Input #intFileNumber, strLineData
        If strLineData <> "" Then
            intLineNum = intLineNum + 1
            For I=1 To 4
                intSeparatorPos = InStr(strLineData, Chr(9))
                strLineData = Right(strLineData, Len(strLineData) - intSeparatorPos)
            Next
            intSeparatorPos = InStr(strLineData, Chr(9))

            recStart    = CDbl(Left(strLineData, intSeparatorPos - 1))
            strLineData = Right(strLineData, Len(strLineData) - intSeparatorPos)

            intSeparatorPos = InStr(strLineData, Chr(9))
            recEnd        = CDbl(Left(strLineData, intSeparatorPos - 1))
            strLineData = Right(strLineData, Len(strLineData) - intSeparatorPos)

            If tmpCalStart > recStart OR tmpCalStart = 0 Then
                tmpCalStart = recStart
            End If
            If tmpCalEnd < recEnd OR tmpCalEnd = 0 Then
                tmpCalEnd = recEnd
            End If
        End If
    Loop
    Seek #intFileNumber, 0

    ReDim arrayLines(intLineNum) As String

    If intLineNum = 0 Then
        shapeTasksTitle.Variable(2).Y = 0
        shapeTasksTitle.PropertyChanged(CDPT_VARIABLE_Y, 2)
    End If

    Dim cur_item As Long
    cur_item = 1
    Do While Not EOF(intFileNumber)
        Line Input #intFileNumber, strLineData
        If strLineData <> "" Then
            arrayLines(cur_item) = strLineData
            cur_item = cur_item + 1
        End If
    Loop
    Close #intFileNumber

    Dim bChangeStart    As Boolean
    Dim bChangeEnd        As Boolean
    Dim dblVal            As Double
    Dim bCalNotReady    As Boolean

    dblVal = shapeTasksTitle.CustomProp(2).Value
    bChangeStart = tmpCalStart < dblVal OR (dblVal = 0)
    dblVal = shapeTasksTitle.CustomProp(3).Value
    bChangeEnd = tmpCalEnd > dblVal OR (dblVal = 0)
    bCalNotReady = FindShapeByNameInGroup(shapeTasksTitle, "Calendar") = Null

    If bChangeStart OR bChangeEnd OR bCalNotReady Then
        shapeTasksTitle.CustomProp(2).Value = tmpCalStart
        shapeTasksTitle.CustomProp(3).Value = tmpCalEnd
        shapeTasksTitle.CustomProp(4).Value = GetRecomendetTimeScale(tmpCalStart, tmpCalEnd)
        BuildCalendar(shapeTasksTitle, 0)
    End If

    intPrevTaskID = 0

    For I=1 To intLineNum
        strLineData = arrayLines(I)
        intFieldNum = 0
        Do
            intSeparatorPos = InStr(strLineData, Chr(9))
            If intSeparatorPos > 0 Then
                strField = Trim(Left(strLineData, intSeparatorPos - 1))
                strLineData = Right(strLineData, Len(strLineData) - intSeparatorPos)
            Else
                strField = Trim(strLineData)
            End If
            Select Case intFieldNum
                Case 0
                    recLevel    = Val(strField)
                Case 1
                    recIsPhase    = Val(strField)
                Case 2
                    recName        = strField
                Case 3
                    recDuration    = CDbl(strField)
                Case 4
                    recStart    = CDbl(strField)
                Case 5
                    recEnd        = CDbl(strField)
                Case 6
                    recComplete    = CDbl(strField)
            End Select
            intFieldNum = intFieldNum + 1
        Loop While intSeparatorPos > 0
        intLastTaskTableID = CreateTaskObjects(recLevel, recName, recDuration, recStart, recEnd, recComplete, recIsPhase)
    Next

'    PlaceLegend(intLastTaskTableID)

    LoadOutline = True
ErrorHandle:
End Function

Function SaveOutline(shapeTasksTitle As Shape, strFileName As String) As Boolean
On Error Goto ErrorHandle
    Dim intFileNumber        As Integer
    Dim strLineData            As String
    Dim intCurTaskID        As Integer
    Dim shapeCurTask        As Shape
    Dim shapeNextTask        As Shape

    Dim recLevel            As Integer
    Dim recIsPhase            As Integer
    Dim recName                As String
    Dim recDuration            As Double
    Dim recStart            As Double
    Dim recEnd                As Double
    Dim recComplete            As Double
    Dim tmpCalStart            As Date
    Dim tmpCalEnd            As Date

    intFileNumber = FreeFile()
    Open strFileName For Output As #intFileNumber

    intCurTaskID = shapeTasksTitle.CustomProp(5).Value
    Do While intCurTaskID <> 0
        Set shapeCurTask = thisDoc.ActivePage.ShapeByID(intCurTaskID)
        If shapeCurTask = Null Then
            Exit Do
        End If
        intCurTaskID = shapeCurTask.CustomProp(5).Value

        Set shapeNextTask = thisDoc.ActivePage.ShapeByID(intCurTaskID)

        recLevel    = shapeCurTask.Variable(9).X
        recIsPhase    = 0
        If shapeNextTask <> Null Then
            If shapeNextTask.Variable(9).X = recLevel + 1 Then
                recIsPhase = 1
            End If
        End If
        recName        = shapeCurTask.CustomProp(1).Value
        recDuration    = CDbl(shapeCurTask.CustomProp(8).Value)
        recStart    = CDbl(CDate(shapeCurTask.CustomProp(6).Value))
        recEnd        = CDbl(CDate(shapeCurTask.CustomProp(7).Value))
        recComplete    = CDbl(shapeCurTask.CustomProp(9).Value) * 100

        strLineData = recLevel & Chr(9) & recIsPhase & Chr(9) & recName & Chr(9) & recDuration & Chr(9) & recStart & Chr(9) & recEnd & Chr(9) & recComplete
        Print #intFileNumber, strLineData
    Loop

    Close #intFileNumber
    SaveOutline = True
ErrorHandle:
End Function

Function ClearPage(shp As Shape) As Integer
    ClearPage = 1
    For I=thisDoc.ActivePage.ShapesNum() To 1 Step -1
        If thisDoc.ActivePage.Shape(I).Name = "TimeLineS" OR thisDoc.ActivePage.Shape(I).Name = "TaskBar" Then
            thisDoc.ActivePage.RemoveShape(I)
        End If
    Next
End Function

Declare Function PPTaskPropDlg Lib "CDWizards" (ByRef strFileName As String) As Long
Declare Function SelectTmpFile Lib "CDWizards" (ByRef sFileName As String, ByVal iLendth As Long) As Long

Function DoShowWizard(shp As Shape) As Integer
On Error Goto ErrorHandle
    Dim strFileName As String
    strFileName = Space(1024)
    SelectTmpFile(strFileName, 1024)
    SaveOutline(shp, strFileName)
    res = PPTaskPropDlg(strFileName)
    If res <> -1 Then
        ClearPage(Null)
        thisDoc.StartRebuild()
        LoadOutline(shp, strFileName)
        thisDoc.EndRebuild()
    End If
ErrorHandle:
End Function